(DE CADDAR (X) (CADDR (CAR X)))

(SETQ QUANTUM -50)
  
(DF DA (1X) (PUT (NEXTL 1X) (CONS LAMBDA 1X) 'AINT))
 
(DE SCHEME ()
  (SETQ *ENV* NIL QUEUE NIL *PROCESS* (CREATEPROCESS '(TOP 'TOPLEVEL)))
  (SWAPIN)
  (SETQ CLOCK QUANTUM)
  (MLOOP))

(DE MLOOP ()
  (SETQ TICK NIL)
  (WHILE T (AND TICK (ALLOW) (SCHEDULE))
           (CLOCK)
           (APPLY *PC* NIL)))

(SETQ TOP '(BETA (LAMBDA (MESSAGE)
  (LABELS
    ((TOP1 (LAMBDA (X) (TOP1 (PRINT (EVALUATE (READ))) ))))
    (TOP1 (PRINT MESSAGE)))) NIL))

(DE SAVEUP (RETAG)
  (SETQ *CLINK* [*EXP* *UNL* *ENV* *EVL* RETAG *CLINK*]))

(DE RESTORE ()
  (IF *CLINK* (MAPC '(*EXP* *UNL* *ENV* *EVL* *PC* *CLINK*)
                    '(LAMBDA (1X) (SET 1X (NEXTL *CLINK*))))
      (ERROR 2)))

(DE ALLOW (;; VCELL)
  (SETQ VCELL (ASSQ '*ALLOW* *ENV*))
  (IF VCELL (CADR VCELL) T))

(DE CLOCK ()
  (INCR CLOCK) (AND (GZP CLOCK) (SETQ TICK T)))

(DE SCHEDULE ()
  (IF QUEUE (PROGN (SWAPOUT) (NCONC1 QUEUE *PROCESS*)
                   (SETQ *PROCESS* (NEXTL QUEUE)) (SWAPIN)))
  (SETQ TICK NIL CLOCK QUANTUM))

(DE SWAPOUT ()
  ((LAMBDA (*CLINK*) (PUT *PROCESS* (SAVEUP *PC*) 'CLINK)
                     (PUT *PROCESS* *VAL* 'VAL))
   *CLINK*))

(DE SWAPIN ()
  (SETQ *CLINK* (GET *PROCESS* 'CLINK) *VAL* (GET *PROCESS* 'VAL))
  (RESTORE))

(DE PRIMOP (X) (MEMQ (TYPEFN X) '(EXPR SUBR)))


(DE AEVAL () (COND
  ((ATOM *EXP*) (COND
      ((OR (NUMBP *EXP*) (PRIMOP *EXP*))
       (SETQ *VAL* *EXP*) (RESTORE))
      ((SETQ TEM (ASSQ *EXP* *ENV*))
       (SETQ *VAL* (CADR TEM)) (RESTORE))
      (T (SETQ *VAL* (CAR *EXP*)) (RESTORE))))
  ((ATOM (SETQ 1X (CAR *EXP*)))
   (COND
    ((= 1X LAMBDA) (SETQ *VAL* ['BETA *EXP* *ENV*]) (RESTORE))
    ((ATOM (CDR 1X))  (SETQ *EVL* NIL *UNL* *EXP* *PC* 'AEVLIS))
    ((SETQ TEM (GET 1X 'AINT)) (SETQ *PC* TEM))
    ((SETQ TEM (GET 1X 'AMACRO)) (SETQ *EXP* (APPLY TEM (CONS *EXP*))))
    (T (SETQ *EVL* NIL *UNL* *EXP* *PC* 'AEVLIS))))
  ((= (CAAR *EXP*) LAMBDA) (SETQ *EVL* (LIST 1X) *UNL* (CDR *EXP*)
                                 *PC* 'AEVLIS))
  (T (SETQ *EVL* NIL *UNL* *EXP* *PC* 'AEVLIS)) ))